home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / BBS_UTL / TOOL_USE / ERRTRAP.PAS < prev    next >
Pascal/Delphi Source File  |  1989-03-01  |  4KB  |  141 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * Runtime error handler - traps and reports runtime errors
  15.  * with full messages. (3-1-89)
  16.  *
  17.  *)
  18.  
  19. unit ErrTrap;
  20.  
  21. {$F+,R-,S-}
  22.  
  23. interface
  24.  
  25.    var
  26.       ExitSave: pointer;   {pointer to next exitproc in the chain}
  27.  
  28.    procedure error_handler;
  29.    function itoh(w: word): string;
  30.    function error_message(code: integer): string;
  31.  
  32.  
  33. implementation
  34.  
  35.    function error_message(code: integer): string;
  36.       {return message text for a given runtime error code}
  37.    var
  38.       class:  string;
  39.       msg:    string;
  40.    begin
  41.       case code of
  42.            1.. 99: class := 'DOS';
  43.          100..149: class := 'I/O';
  44.          150..199: class := 'CRITICAL';
  45.          200..249: class := 'FATAL';
  46.          else      class := 'UNKNOWN';
  47.       end;
  48.  
  49.       case code of
  50.            2: msg := 'File not found';
  51.            3: msg := 'Path not found';
  52.            4: msg := 'Too many open files';
  53.            5: msg := 'File access denied';
  54.            6: msg := 'Bad file handle';
  55.           12: msg := 'Bad file access code';
  56.           15: msg := 'Bad drive number';
  57.           16: msg := 'Can''t remove current dir';
  58.           17: msg := 'Can''t rename across drives';
  59.  
  60.          100: msg := 'Disk read error';
  61.          101: msg := 'Disk write error';
  62.          102: msg := 'File not assigned';
  63.          103: msg := 'File not open';
  64.          104: msg := 'File not open for input';
  65.          105: msg := 'File not open for output';
  66.          106: msg := 'Bad numeric format';
  67.  
  68.          150: msg := 'Disk is write-protected';
  69.          151: msg := 'Unknown diskette unit';
  70.          152: msg := 'Drive not ready';
  71.          153: msg := 'Unknown command';
  72.          154: msg := 'CRC error in data';
  73.          155: msg := 'Bad drive request structure length';
  74.          156: msg := 'Disk seek error';
  75.          157: msg := 'Unknown diskette type';
  76.          158: msg := 'Sector not found';
  77.          159: msg := 'Printer out of paper';
  78.          160: msg := 'Device write fault';
  79.          161: msg := 'Device read fault';
  80.          162: msg := 'Hardware failure';
  81.  
  82.          200: msg := 'Division by zero';
  83.          201: msg := 'Range check';
  84.          202: msg := 'Stack overflow';
  85.          203: msg := 'Heap overflow';
  86.          204: msg := 'Bad pointer operation';
  87.          205: msg := 'Floating point overflow';
  88.          206: msg := 'Floating point underflow';
  89.          207: msg := 'Bad floating point operation';
  90.  
  91.          else str(code,msg);
  92.       end;
  93.  
  94.       error_message := class + ' ERROR: ' + msg;
  95.    end;
  96.  
  97.  
  98.    function itoh(w: word): string;
  99.       {hex conversion}
  100.    const
  101.       hex: array[0..15] of char = '0123456789ABCDEF';
  102.    var
  103.       h: string[4];
  104.    begin
  105.       h[0] := chr(4);
  106.       h[1] := hex[(w shr 12) and $0F];
  107.       h[2] := hex[(w shr  8) and $0F];
  108.       h[3] := hex[(w shr  4) and $0F];
  109.       h[4] := hex[w          and $0F];
  110.       itoh := h;
  111.    end;
  112.  
  113.  
  114.    procedure error_handler;
  115.       {exit handler, checks for I/O and runtime errors}
  116.    begin
  117.       {link to the next exitproc when this one's finished}
  118.       ExitProc := ExitSave;
  119.  
  120.       {all finished unless there is an error}
  121.       if ErrorAddr = nil then
  122.          exit;
  123.  
  124.       {generate error message text and clear the error condition}
  125.       writeln(^G);
  126.       writeln('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒');
  127.       writeln('▒▒▒▒▒      Runtime error ',ExitCode:3,' at location ',
  128.               itoh(seg(ErrorAddr^)),':',itoh(ofs(ErrorAddr^)),  '     ▒▒▒▒▒');
  129.       writeln('▒▒▒▒▒':60,^M'▒▒▒▒▒      ',error_message(ExitCode));
  130.       writeln('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒');
  131.       ErrorAddr := nil;
  132.    end;
  133.  
  134.  
  135. (* install new runtime error handler *)
  136. begin
  137.    ExitSave := ExitProc;        {save link to next handler in chain}
  138.    ExitProc := @error_handler;  {link in my handler}
  139. end.
  140.  
  141.